Turnbull China Bikeride/Turnbull China Bikeride - Disc 2.iso/BARNET/COMPILER/SATHER/!Sather/Library/Base/sa/flt

Text File | 1996-07-18 | 20KB | 662 lines

---------------------------> Sather 1.1 source file <--------------------------
-- Copyright (C) International Computer Science Institute, 1994.  COPYRIGHT  --
-- NOTICE: This code is provided "AS IS" WITHOUT ANY WARRANTY and is subject --
-- to the terms of the SATHER LIBRARY GENERAL PUBLIC LICENSE contained in    --
-- the file "Doc/License" of the Sather distribution.  The license is also   --
-- available from ICSI, 1947 Center St., Suite 600, Berkeley CA 94704, USA.  --
--------> Please email comments to "[e-mail]". <----------

immutable class FLT < $NUMBER{FLT}, $HASH, $FMT is
   -- IEEE 754-1984 "single" format 32-bit floating point.
   -- Most of these functions presently just call the FLTD versions
   -- because of C double/float calling convention weirdness; this
   -- is the most portable way.
   include COMPARABLE;


   plus(f:SAME):SAME is
      -- The sum of self and `f'. Built-in.
      builtin FLT_PLUS;
   end;

   minus(f:SAME):SAME is
      -- The difference between self and `f'. Built-in.
      builtin FLT_MINUS;
   end;

   negate:SAME is
      -- The negation of self. Same as zero minus self,
      -- except that IEEE does funny things for the sign bit and
      -- different rounding modes.
      builtin FLT_NEGATE;
   end;

   times(f:SAME):SAME is
      -- The signed product of self and `f'. Built-in.
      builtin FLT_TIMES;
   end;

   div(f:SAME):SAME is
      -- The quotient of self and `f'. Built-in.
      builtin FLT_DIV;
   end;

   is_eq(f:SAME):BOOL is
      -- True if self and `f' represent the same value.  Built-in.
      builtin FLT_IS_EQ;
   end;

   is_lt(f:SAME):BOOL is    -- True if self is less than `f'. Built-in.
      builtin FLT_IS_LT;
   end;

   is_bet(l,u:SAME):BOOL is
      -- Another name for `is_between'.
      return self.is_between(l,u)
   end;

   is_between(l,u:SAME):BOOL is
      -- True if self between l and u.
      return (l<=self and self<=u) or (u<=self and self<=l) end;

   is_within(tolerance,val:SAME):BOOL is
      return (self-val).abs<=tolerance;
   end;

   hash:INT is
      -- A lousy hash function, can someone suggest better?
      return truncate.int.hash;
   end;

   is_finite:BOOL is        -- returns true if zero, subnormal or normal.
      return RUNTIME::ir_finite(self);
   end;

   is_inf:BOOL is        -- returns true if infinite
      return RUNTIME::ir_isinf(self);
   end;

   is_nan:BOOL is
      -- returns true if NaN.  See comment at "is_nil".
      return ~(self=self);
   end;

   is_normal:BOOL is        -- returns true if normal
      builtin IR_ISNORMAL;
   end;

   is_subnormal:BOOL is        -- returns true if subnormal
      builtin IR_ISSUBNORMAL;
   end;

   is_zero:BOOL is        -- returns true is zero
      builtin IR_ISZERO;
   end;

   signbit_set:BOOL is        -- returns true if sign bit of self is set
      builtin IR_SIGNBIT;
   end;

   unbiased_exponent:INT is
      -- return unbiased exponent of self as an INT;
      -- for zero this is INT::maxint.negate, for an
      -- infinite it is INT::maxint.  If subnormal,
      -- normalization occurs first.
      builtin IR_ILOGB;
   end;

   copysign(y:SAME):SAME is
      -- return self with the sign bit set to the same as y's sign bit.
      builtin R_COPYSIGN;
   end;

   nextup:SAME is        -- return next representable number from self.
      builtin R_NEXTUP;
   end;

   nextdown:SAME is
      -- return previous representable number from self.
      builtin R_NEXTDOWN;
   end;

   remainder(y:SAME):SAME is
      -- x.remainder(y) and x.mod(y) return a remainder of x with respect
      -- to y; that is, the result r is one of the numbers that differ from
      -- x by an integral multiple of y.  Thus (x-r)/y  is an integral
      -- value, even though it might exceed INT::maxint if it were
      -- explicitly computed as an INT.  Both functions return one  of the
      -- two such r smallest in magnitude.  remainder(x,y) is the operation
      -- specified in ANSI/IEEE Std 754-1985; the result of x.mod(y) may
      -- differ from remainder's result by +-y.  The magnitude of
      -- remainder's result can not exceed half that of y; its sign might
      -- not agree with either x or y.  The magnitude of mod's result is
      -- less than that of y; its sign agrees with that of x.  Neither
      -- function will raise an exception as long as both arguments are
      -- normal or subnormal.  x.remainder(0), x.mod(0), infinity.remainder(y),
      -- and infinity.mod(y) are invalid operations that produce a NaN.

      builtin R_REMAINDER;
   end;

   mod(y:SAME):SAME is    -- See comment at `remainder'.
      builtin R_FMOD;
   end;

   scale_by(n:INT):SAME is
      -- return x*2.pow(n) computed by exponent manipulation rather
      -- than by actually performing an exponentiation or a multiplication.
      --
      --    1 <= x.abs.scale_by(-x.unbiased_exponent) < 2
      --
      -- for every x except 0, infinity, and NaN.
      builtin R_SCALBN;
   end;

   bessel_j0:SAME is
      -- Bessel functions of the first and second kinds.  y0, y1 and yn have
      -- logarithmic singularities at the origin, so they treat zero and
      -- negative arguments the way log does.
      builtin R_J0;
   end;

   bessel_j1:SAME is
      -- See comment at `bessel_j0'.
      builtin R_J1;
   end;

   bessel_jn(n:INT):SAME is
      -- See comment at `bessel_j0'.
      builtin R_JN;
   end;

   bessel_y0:SAME is
      -- See comment at `bessel_j0'.
      builtin R_Y0;
   end;

   bessel_y1:SAME is
      -- See comment at `bessel_j0'.
      builtin R_Y1;
   end;

   bessel_yn(n:INT):SAME is
      -- See comment at `bessel_j0'.
      builtin R_YN;
   end;

   erf:SAME is
      -- error function:
      --   x.erf = (1/sqrt(pi))*integrate(0,x,exp(-t^2)dt)
      builtin R_ERF;
   end;

   one_minus_erf:SAME is
      -- 1.0-self.erf, but computed in a way to avoid
      -- cancellation for large self.
      builtin R_ERFC;
   end;

   exp:SAME is            -- The exponential e^self.
      -- Exponential, logarithm, power functions.  All these functions handle
      -- exceptional arguments in the spirit of IEEE 754-1985.  So:
      --    0.log is -infinity with a division by zero exception
      --    For x<0, including -infinity, x.log is a quiet NaN with an
      --    invalid op exception
      --    For x=+infinity or a quiet NaN, x.log is x without exception
      --    For a signaling NaN, x.log is a quiet NaN with
      --    an invalid op exception
      --    1.log is zero without exception
      -- For any other positive x, x.log is a normalized number with an
      -- inexact exception.

      builtin R_EXP;
   end;

   exp_minus_one:SAME is    -- e^self-1.0, accurate even for tiny self.
      -- See comment at `exp'.
      builtin R_EXPM1;
   end;

   exp2:SAME is            -- 2^self
      -- See comment at `exp'.
      builtin R_EXP2;
   end;

   exp10:SAME is        -- 10^self
      -- See comment at `exp'.
      builtin R_EXP10;
   end;

   log:SAME is            -- The natural logarithm of self.
      -- See comment at `exp'.
      builtin R_LOG;
   end;

   plus_one_log:SAME is        -- (self+1).log, accurate even for tiny self.
      -- See comment at `exp'.
      builtin R_LOG1P;
   end;

   log2:SAME is            -- The logarithm base two of self.
      -- See comment at `exp'.
      return self.log*log2_e;
   end;

   log10:SAME is        -- The logarithm base ten of self.
      -- See comment at `exp'.
      builtin R_LOG10;
   end;

   pow(arg:SAME):SAME is
      -- self raised to the arg'th power.  x.pow(0.0)=1.0 for all x.
      -- See comment at `exp'.
      builtin R_POW;
   end;

   acosh:SAME is        -- The inverse hyperbolic cosine of self.
      -- The hyperbolic functions handle exceptional arguments in the
      -- spirit of IEEE 754-1985.  So:
      --    sinh and cosh return +-infinity on overflow
      --    acosh returns a NaN if its argument is less than 1.0
      --    atanh returns a NaN if its argument has an absolute value >1.0
      builtin R_ACOSH;
   end;

   cosh:SAME is            -- The hyperbolic cosine of self.
      -- See comment at `acosh'.
      builtin R_COSH;
   end;

   sinh:SAME is            -- The hyperbolic sine of self.
      -- See comment at `acosh'.
      builtin R_SINH;
   end;

   tanh:SAME is            -- The hyperbolic tangent of self.
      -- See comment at `acosh'.
      builtin R_TANH;
   end;

   asinh:SAME is        -- The inverse hyperbolic sine of self.
      -- See comment at `acosh'.
      builtin R_ASINH;
   end;

   atanh:SAME is        -- The inverse hyperbolic tangent of self.
      -- See comment at `acosh'.
      builtin R_ATANH;
   end;


   hypot(arg:SAME):SAME is
      -- sqrt(self*self+arg*arg), taking precautions against unwarranted
      -- IEEE exceptions.  +-infinity.hypot(arg) is +infinity for any arg,
      -- even a NaN, and is exceptional only for a signaling NaN.
      builtin R_HYPOT;
   end;

   acos:SAME is
      -- The arc sine of self in the range [0.0, pi].
      -- The trigonometric functions handle exceptional arguments
      -- in the spirit of IEEE 754-1985.  So:
      --    +-infinity.sin, +-infinity.cos, +-infinity.tan return NaN
      --    x.asin and x.acos with x.abs>1 return NaN
      -- sinpi etc. are similar except they compute
      -- self.sinpi=(self*pi).sin avoiding range-reduction issues
      -- because their definition permits range reduction that is fast
      -- and exact for all self.  The corresponding inverse functions
      -- compute asinpi(x).
      builtin R_ACOS;
   end;

   sin:SAME is             -- See comment at `acos'.
      builtin R_SIN;
   end;

   cos:SAME is             -- See comment at `acos'.
      builtin R_COS;
   end;

   sincos(out s:FLT,out c:FLT) is
      -- Simultaneous computation of self.sin and self.cos.  This is faster
      -- than independently computing them.
      -- See comment at `acos'.
      builtin SINCOS;
   end;

   tan:SAME is
      -- See comment at `acos'.
      builtin R_TAN;
   end;

   asin:SAME is
      -- The arc sine of self in the range [-pi/2, pi/2]
      -- See comment at `acos'.
      builtin R_ASIN;
   end;

   atan:SAME is
      -- The arc tangent of self in the range [-pi/2, pi/2].
      -- See comment at `acos'.
      builtin R_ATAN;
   end;

   atan2(arg:SAME):SAME is
      -- The arc tangent of self divided by arg in the range [-pi/2, pi/2].
      -- It chooses the quadrant specified by (self, arg).
      -- See comment at `acos'.
      builtin R_ATAN2;
   end;

   sinpi:SAME is
      -- See comment at `acos'.
      builtin R_SINPI;
   end;

   cospi:SAME is
      -- See comment at `acos'.
      builtin R_COSPI;
   end;

   sincospi(out a:FLT,out b:FLT) is
      -- Simultaneous computation of self.sinpi and self.cospi.  Faster
      -- than independently computing them.
      -- See comment at `acos'.
      builtin SINCOSPI;
   end;

   tanpi:SAME is
      -- See comment at `acos'.
      builtin R_TANPI;
   end;

   asinpi:SAME is
      -- The arc sine of self*pi in the range [-pi/2, pi/2]
      -- See comment at `acos'.
      builtin R_ASINPI;
   end;

   acospi:SAME is
      -- The arc sine of self*pi in the range [0.0, pi]
      -- See comment at `acos'.
      builtin R_ACOSPI;
   end;

   atanpi:SAME is
      -- The arc tangent of self*pi in the range [-pi/2, pi/2].
      -- See comment at `acos'.
      builtin R_ATANPI;
   end;

   atan2pi(arg:SAME):SAME is
      -- The arc tangent of self*pi divided by arg in the range [-pi/2, pi/2].
      -- It chooses the quadrant specified by (self, arg).
      -- See comment at `acos'.
      builtin R_ATAN2PI;
   end;

   abs:SAME is            -- The absolute value of self.
      builtin R_FABS;
   end;

   sign:SAME is
      -- -1.0, 0.0, or 1.0, depending whether the sign of self is
      -- negative, zero, or positive.
      if self<0.0 then return -1.0;
      elsif self>0.0 then return 1.0;
      else return 0.0;
      end;
   end;

   signum:SAME is return sign end; -- Another name for `sign'.

   log_gamma:SAME is
      -- log gamma function.  x.ln_gamma=x.gamma.abs.log
      builtin R_LGAMMA;
   end;

   gamma:SAME is
      -- gamma function.
      if self>0.0 then return log_gamma.exp;
      elsif integral then return 0.0;
      elsif abs.floor.int.is_even then return (-log_gamma).exp;
      else return log_gamma.exp;
      end;
   end;

   sqrt:SAME is            -- The square root of self.
      builtin R_SQRT;
   end;

   square:SAME is        -- The square of self.
      return self*self;
   end;

   cube_root:SAME is        -- The cube root of self.
      builtin R_CBRT;
   end;

   cube:SAME is            -- The cube of self.
      return self*self*self;
   end;

   max(arg:SAME):SAME is    -- The larger of self and arg.
      -- Caution: may not work as one expects if an argument is NaN.
      if self<arg then return arg; else return self; end;
   end;

   min(arg:SAME):SAME is    -- The smaller of self and arg.
      -- Caution: may not work as one expects if an argument is NaN.
      if self<arg then return self; else return arg; end;
   end;

   at_least(arg:SAME):SAME is return self.max(arg) end; -- Same as `self.max(arg)'
   at_most(arg:SAME):SAME is return self.min(arg) end; -- Same as `self.min(arg)'

   str:STR is
      -- A string version of self.
      fbuf:FSTR:=#(30);  -- This is poor, but makes it reentrant.
             -- The other str methods work this way too
             -- (they used to use a shared buffer.)
      -- if ((void(fbuf)) or (fbuf.size < 30)) then fbuf := #FSTR(30) end;
      fstr ::= str_in(fbuf);
      return(fstr.str); end;

   str(prec:INT):STR is
      -- A string version of self with arg digits of precision.
      des_sz ::= prec+10;
      fbuf:FSTR:=#(des_sz); -- See comment in `str'.
      -- if ((void(fbuf)) or (fbuf.size < des_sz)) then fbuf:=#FSTR(des_sz) end;
      fstr ::= str_in(fbuf,prec);
      return(fstr.str);  end;

   str_in(arg:FSTR):FSTR is
      store_in: FSTR;
      if (arg.size >= 30) then store_in := arg;
      else store_in := #FSTR(30) end;
      sz ::= store_into(store_in);
      store_in.loc := sz;
      return(store_in); end;

   str_in(arg: FSTR, prec: INT): FSTR is
      store_in: FSTR;
      des_sz ::= prec+10;
      if (arg.size >= des_sz) then store_in := arg;
      else store_in := #FSTR(des_sz) end;
      sz ::= store_into_prec(prec, store_in);
      store_in.loc := sz;
      return(store_in);  end;

   private store_into(s:FSTR):INT is
      -- Store the acsii representation into s.  Built-in.
      builtin FLT_STORE_INTO;
   end;

   private store_into_prec(p:INT,s:FSTR):INT is
      -- Store the acsii representation into s with precision p.  Built-in.
      builtin FLT_STORE_PREC;
   end;

   fmt( f:STR ): STR is
      -- Return a nicely formatted ascii representation of the number.
      -- See the separate documentation on FMT for a full description.
      return BASE_FORMAT::fmt_flt( self, f )
   end;

   create (s: STR): SAME is
      builtin ATOF;
   end;

   create(f:INT):SAME is return f.flt end;
   create(f:INTI):SAME is return f.flt end;
   create(f:FLT):SAME is return f end;
   create(f:FLTD):SAME is return f.flt end;

   --    create(f:FLTX):SAME is return f.flt end;
   --    create(f:FLTDX):SAME is return f.flt end;
   --    create(f:FLTI):SAME is return f.flt end;

   integral:BOOL is
      -- Another name for `is_integral'.
      return self.is_integral
   end;

   is_integral:BOOL is
      -- Return true if self is integral.
      return self=truncate;
   end;

   int:INT is
      -- INT version of self.  It is an error if self is not integral.
      -- Use truncate, floor, ceiling, or round to achieve this.
      -- Built-in.
      builtin FLT_INT;
   end;

   inti:INTI is return #INTI(self) end; -- Conversion to INTI.

   flt:FLT is return self end; -- Conversion to FLT (identity operation)

   fltd:FLTD is
      -- An FLTD version of self.  Built-in.
      builtin FLT_FLTD; end;

   get_representation(out sign:BOOL,out exp: INT,out mantissa: INT)
    -- Get the data representing te flt. (endian independant)
   is
      builtin FLT_GET_REP;
   end;

   truncate:SAME is        -- The nearest integer toward zero.  Built-in.
      builtin FLT_TRUNCATE;
   end;

   floor:SAME is        -- The largest integer not greater than self.
      builtin R_FLOOR;
      -- return RUNTIME::r_floor(self);
   end;

   ceiling:SAME is        -- The smallest integer not less than self.
      builtin R_CEIL;
      -- return RUNTIME::r_ceil(self);
   end;

   round:SAME is        -- The closest integer to self.
      builtin FLT_ROUND;
   end;

   const pi:SAME:=FLTD::pi.flt; -- An approximation of the mathematical value "pi".

   const e:SAME:=FLTD::e.flt; -- An approximation of the base of the natural logarithms "e".

   const sqrt_2:SAME:=FLTD::sqrt_2.flt; -- Approximation of 2.sqrt.
   const log_2:SAME:=FLTD::log_2.flt; -- Approximation of 2.log.
   const log2_e:SAME:=FLTD::log2_e.flt; -- Approximation of e.log2.
   const log10_e:SAME:=FLTD::log10_e.flt; -- Approximation of e.log10.
   const log_10:SAME:=FLTD::log_10.flt; -- Approximation of 10.log.
   const half_pi:SAME:=FLTD::half_pi.flt; -- Approximation of pi/2.
   const quarter_pi:SAME:=FLTD::quarter_pi.flt; -- Approximation of pi/4.
   const inv_sqrt_2:SAME:=FLTD::inv_sqrt_2.flt; -- Approximation of 1/(2.sqrt).
   const inv_pi:SAME:=FLTD::inv_pi.flt; -- Approximation of 1/pi.
   const double_inv_pi:SAME:=FLTD::double_inv_pi.flt; -- Approximation of 2/pi
   const double_sqrt_pi:SAME:=FLTD::double_sqrt_pi.flt;
   -- Approximation of 2*(pi.sqrt).


   nil:SAME is
      -- The value to be used to represent no element in sets.
      return signaling_NaN(0);
   end;

   is_nil:BOOL is
      return ~(self=self);
      -- Blame IEEE arithmetic for this.  I know how awful it looks.
      -- It works because NaN is the only value which won't compare
      -- with anything.
   end;

   signaling_NaN(sig:INT):SAME is
      -- IEEE signalling NaN.  `sig' is the significand (presently unused).
      builtin R_SIGNALING_NAN;
   end;

   quiet_NaN(sig:INT):SAME is
      -- IEEE quiet NaN.  `sig' is the significand (presently unused).
      builtin R_QUIET_NAN;
   end;

   infinity:SAME is        -- IEEE Infinity.
      builtin R_INFINITY;
   end;

   const zero:SAME := 0.0;               -- See $NUMBER.
   const one: SAME := 1.0;
   maxval:SAME is return infinity; end;  -- Maximal value; see $NUMBER.
   minval:SAME is return -infinity; end; -- Minimal value; see $NUMBER.

   const epsilon:SAME:=1.19209290e-07; -- The minimum x>0.0 such that 1.0+x/=x.

   const digits:INT:=6;        -- The number of decimal digits of precision.

   const mantissa_bits:INT:=24; -- The number of bits in the significand, including an implied bit.

   min_normal:SAME is        -- The smallest normalized positive number.
      builtin MIN_NORMAL;
   end;

   max_normal:SAME is        -- The largest normalized positive number.
      builtin MAX_NORMAL;
   end;

   min_subnormal:SAME is    -- The smallest subnormal positive number.
      builtin MIN_SUBNORMAL;
   end;

   max_subnormal:SAME is    -- The largest subnormal positive number.
      builtin MAX_SUBNORMAL;
   end;

   const min_exp:INT:=-125;
   -- The minimum negative integer x such that b^(x-1) is in the range
   -- of normalized floating point numbers.

   const min_exp10:INT:=-37;
   -- The minimum x such that 10^x is in the range of normalized
   -- floating point numbers.

   const max_exp:INT:=128; -- The maximum allowable exponent.

   const max_exp10:INT:=38;-- The maximum x such that 10^x is within range.

   sum!(i:SAME):SAME is
      -- Yields the sum of all previous values of `i'.
      r::=0.0; loop r:=r+i; yield r end
   end;

   product!(i:SAME):SAME is
      -- Yields the product of all previous values of `i'.
      r::=1.0; loop r:=r*i; yield r end
   end;

end; -- class FLT